POINT Software Programming/PPROG1.ISO/pascal/swag/misc.swg/0034_Detect Float Error.pas

Pascal/Delphi Source File | 1993-08-27 | 17.1 KB | 804 lines

{
GERD KORTEMEYER

here are two Units For trapping float-exceptions. In your Program you
will have to add

  Uses err387

and at the beginning of your main Program say For example

begin
   exception(overflow, masked);
   exception(underflow, dumpask);
   exception(invalid, dumpexit);
   autocorrect(zerodiv, 1.0);
   exception(precision, masked);

In this way you can choose For any kind of exception in which way it is
to be handeled. After the lines above the result of a division by zero
will be '1.0', in Case of an underflow there will be a dump of the copro
and the user will be asked For the result he wants the operation to have,
in Case of an overflow the largest available number will be chosen and
so on ...

Here are the Units

    err387 and dis387
}

{ ---------------------------------------------------------- }
{ Fehlerbehandlungsroutinen fuer den Intel 80387 bzw. 486 DX }
{ Geschrieben in Turbo Pascal 6.0                            }
{ von Gerd Kortemeyer, Hannover                              }
{ ---------------------------------------------------------- }

Unit err387;

Interface

Uses
  dis387, Dos, Crt;

Const
  invalid   = 1;
  denormal  = 2;
  zero_div  = 4;
  overflow  = 8;
  underflow = 16;
  precision = 32;
  stackfault= 64;
  con1      = 512;

  masked    = 0;
  runtime   = 1;
  dump      = 2;
  dumpexit  = 3;
  dumpask   = 4;
  autocorr  = 5;


Procedure exception(which, what : Word);
Procedure autocorrect(which : Word; by : Extended);

Procedure handle_off;
Procedure handle_on;

Procedure restore_masks;

Procedure clear_copro;
Function  status_Word : Word;

Var
  do_again : Word;

Implementation

Const
  valid = 0;
  zero  = 1;
  spec  = 2;
  empty = 3;

  topmask : Word = 14336;
  topdiv  = 2048;

  anyerrors : Word = 63;

  zweipot : Array [0..15] of Word =
    (1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,
     2048, 4096, 8192, 16384, 32768);

  ex_nam : Array[0..5] of String=
    ('Invalid   ',
     'Denormal  ',
     'Zero-Div  ',
     'Overflow  ',
     'Underflow ',
     'Precision ');

Var
  setmasks : Byte;
  normal   : Record
    Case Boolean OF
      True : (adr : Pointer);
      False: (pro : Procedure);
    end;

  Exit_on,
  dump_on,
  ask_on,
  auto_on,
  standard : Word;

  auto_val : Array [0..5] of Extended;

Procedure Mask(which : Word);
Var
  cw : Word;
begin
  Asm
    fstcw cw
  end;
  cw := cw or which;
  setmasks := Lo(cw);
  Asm
    fldcw cw
  end;
end;

Procedure Unmask(which : Word);
Var
  cw : Word;
begin
  Asm
    fclex
    fstcw cw
  end;
  cw := cw and not (which);
  setmasks := Lo(cw);
  Asm
    fldcw cw
  end;
end;

Procedure restore_masks;
Var
  setm : Word;
  i    :Integer;
begin
  setm:=setmasks;
  For i := 0 to 5 do
    if (setm and zweipot[i]) <> 0 then
      Mask  (zweipot[i])
    else
      Unmask(zweipot[i]);
end;

Procedure clear_copro;
Var
  cw : Word;
begin
  Asm
    fstcw cw
  end;
  setmasks := Lo(cw);
  Asm
    finit
  end;
end;

Function status_Word;
begin
  Asm
    fstsw @result
  end;
end;

{ Bei welcher Exception soll was passieren? }
Procedure exception;
begin
  Case what OF

    masked  : Mask(which);

    runtime :
      begin
        Unmask(which);
        standard := standard or which;
      end;

    dump :
      begin
        Unmask(which);
        standard := standard and NOT(which);
        dump_on  := dump_on  or  which;
        Exit_on  := Exit_on  and NOT(which);
        ask_on   := ask_on   and NOT(which);
        auto_on  := auto_on  and NOT(which);
      end;

    dumpexit :
      begin
        Unmask(which);
        standard := standard and NOT(which);
        dump_on  := dump_on  or  which;
        Exit_on  := Exit_on  or  which;
        ask_on   := ask_on   and NOT(which);
        auto_on  := auto_on  and NOT(which);
      end;

    dumpask :
      begin
        Unmask(which);
        standard := standard and NOT(which);
        dump_on  := dump_on  or  which;
        Exit_on  := Exit_on  and NOT(which);
        ask_on   := ask_on   or  which;
        auto_on  := auto_on  and NOT(which);
      end;
   end;
end;

{ zum Setzen von Auto-Korrekt-Werten }

Procedure autocorrect;
Var
  i : Integer;
begin
   Unmask(which);
   standard := standard and NOT(which);
   dump_on  := dump_on  and NOT(which);
   Exit_on  := Exit_on  and NOT(which);
   ask_on   := ask_on   and NOT(which);
   auto_on  := auto_on  or  which;
   For i := 0 to 5 do
     if (which and zweipot[i]) <> 0 then
       auto_val[i] := by;
end;

{ ------------- Die Interrupt-Routine selbst ------------- }

Procedure errorcon; Interrupt;
Var
  copro : Record
    control_Word,
    status_Word,
    tag_Word, op,
    instruction_Pointer,
    ip, operand_Pointer, : Word;
    st                   : Array [0..7] of Extended;
  end;

  top : Integer; { welches Register ist Stacktop? }

  masked,            { welche Exceptions maskiert? }
  occured : Byte;    { welche Exceptions aufgetreten? }

  opcode  : Word;

  inst_seg,       { Instruction-Pointer, Segment }
  inst_off,       { "                  , Offset  }
  oper_seg,       { Operand-Pointer    , Segment }
  oper_off: Word; { "                  , Offset  }

  inst_point : ^Word;                 { zum Adressieren des Opcodes }

  oper_point : Record
    Case Integer of { zum Adressieren des Operanden }
      1 : (ex : ^Extended);
      2 : (db : ^Double);
      3 : (si : ^Single);
      4 : (co : ^Comp);
    end;

  marker: Array [0..7] of Word; { Register-Marker nach Tag-Word }

  opt_dump,               { soll ausgeben werden? }
  opt_exit,               { soll aufgehoert werden? }
  opt_ask,                { soll Ergebnis abgefragt werden? }
  opt_auto  : Boolean;    { soll Ergebnis automatisch korrigiert werden? }

  i         : Integer;

  mem_access: Boolean;    { gibt es Speicherzugriff? }

  op_name   : String;     { Mnemonik des Befehls }

{ Ersetze Stacktop durch abgefragten Wert }
Procedure ask_correct;
Var
  res  : Extended;
  ch   : Char;
  t    : String;
  code : Integer;
begin
   Asm
     fstp res
   end;
   WriteLN;
   Write('The result would be ', res, '. Change? (y/n) ' );
   Repeat
     Repeat Until KeyPressed;
     ch := ReadKey;;
   Until ch in ['Y','y','N','n'];
   Writeln;
   if ch in ['Y','y'] then
   Repeat
     Write('New value : ');
     READLN(t);
     VAL(t, res, code);
   Until code = 0;
   Asm
     fld res
   end;
end;

Function hex(w : Word) : String; { Ausgabe als HeX-Zahl }
Const
  zif : Array [0..15] of Char = ('0','1','2','3','4','5','6','7','8','9',
                                    'a','b','c','d','e','f');
begin
  hex := zif[w div zweipot[12]] +
         zif[(w MOD zweipot[12]) div zweipot[8]] +
         zif[(w MOD zweipot[8]) div zweipot[4]] +
         zif[w MOD zweipot[4]];
end;

Procedure choice;
Var
  ch : Char;
begin
  WriteLN;
  Write('C)ontinue, A)bort ');
  Repeat
    Repeat Until KeyPressed;
    ch:=ReadKey;;
    if ch in ['A','a'] then
      Halt(0);
  Until ch in ['C','c'];
  WriteLN;
end;

Procedure showcopro; { Ausgeben des FSAVE - Records }
Var
  i : Integer;
begin
  TextMode(LastMode);
  HighVideo;
  WriteLN('Floating point exception, last opcode: ',hex(opcode),
                                               ' (',op_name,')');
  NormVideo;
  WriteLN('Instruction Pointer : ',hex(inst_seg),':',hex(inst_off),
          ' (',hex(inst_point^),')');
  if mem_access then
  begin
    WriteLN('Operand Pointer     : ',hex(oper_seg),':',hex(oper_off));
    WriteLN('( Extended: ',oper_point.ex^,', Double: ',oper_point.db^);
    WriteLN('  Single  : ',oper_point.si^,', Comp  : ',oper_point.co^,' )');
  end
  else
  begin
    WriteLN;
    WriteLN ('No memory access');
    WriteLN;
  end;
  HighVideo;
  if (occured and stackfault) = 0 then
  begin
    WriteLN('Exception ','Masked':8,'Occured':8,'Should be masked':18);
    NormVideo;
    For i:=0 to 5 do
      WriteLN(ex_nam[i], (masked   and zweipot[i]) <> 0 : 8,
                         (occured  and zweipot[i]) <> 0 : 8,
                         (setmasks and zweipot[i]) <> 0 : 18);
    HighVideo;
  end
  else
  begin
    WriteLN('Invalid Operation:');
    if (copro.status_Word and con1) <> 0 then
      WriteLN('                       -- Stack Overflow --')
    else
      WriteLN('                       -- Stack Underflow --');
    WriteLN;
  end;

  WriteLN('Reg  ','Value':29,'Marked':10);
  Normvideo;
  For i := 0 to 7 do
  begin
    Write('st(',i,')', copro.st[i] : 29);
    Case marker[i] OF
       valid : WriteLN('Valid'   : 10);
       spec  : WriteLN('Special' : 10);
       empty : WriteLN('Empty'   : 10);
       zero  : WriteLN('Zero'    : 10);
    end;
  end;
end;

{ Ersetze Stacktop durch Auto-Korrekt-Wert }

Procedure auto_corr;
Var
  res : Extended;
  i   : Integer;
begin
  Asm
    fstp res
  end;
  For i := 0 to 5 do
    if ((occured and zweipot[i]) <> 0) and
       ((auto_on and zweipot[i]) <> 0) then
      res := auto_val[i];
  Asm
    fld res
  end;
end;


Procedure do_it_again;
Type
  codearr = Array[0..4] of Byte;
Var
  sam : Record
    Case Boolean OF
      True : (b: ^codearr );
      False: (p: Procedure);
    end;

  op_point : Pointer;
  x        : extended;
begin
  New(sam.b);
  sam.b^[0]:=Hi(opcode);
  sam.b^[1]:=Lo(opcode);
  if mem_access then
  begin
  { --- mod r/m auf ds:[di] stellen (00ttt101) --- }
    sam.b^[1] := sam.b^[1] and not (zweipot[7] + zweipot[6] + zweipot[1]);
    sam.b^[1] := sam.b^[1] or (zweipot[2] + zweipot[0]);
  end;
  sam.b^[2] := $ca; { retf 0000 }
  sam.b^[3] := $00;
  sam.b^[4] := $00;
  op_point  := oper_point.ex;
  Asm
    push ds
    lds di, op_point
  end;

  sam.p;

  Asm
    pop ds
  end;
  Dispose(sam.b);
end;

begin
  Asm
    push   ax
    xor    al,al
    out    0f0h,al
    mov    al,020h
    out    0a0h,al
    out    020h,al
    pop    ax
    fsave  copro
  end;

  { === Pruefen, ob Bearbeitung durch ERRORCON erwuenscht === }
  if (copro.status_Word and standard) <> 0 then
  begin
    Asm
      frstor copro
    end;
    normal.pro; { Bye, bye ... }
  end;
  { === Auswerten des FSAVE-Records ========================= }
  { --- Opcode wie im Copro gespeichert     --- }
  opcode := zweipot[15] + zweipot[14] + zweipot[12] + zweipot[11] +
            (copro.ip MOD zweipot[11]);
  op_name := dis(opcode);
  mem_access := op_name='...';
  { --- Was war maskiert, was ist passiert? --- }
  masked  := Lo(copro.control_Word);
  occured := Lo(copro.status_Word );
  { --- Der Instruction-Pointer             --- }
  inst_seg := copro.ip and (zweipot[15] + zweipot[14] + zweipot[13] +
                           zweipot[12]);
  inst_off := copro.instruction_Pointer;
  inst_point := Ptr(inst_seg,inst_off);
  { --- Der Operand-Pointer                 --- }
  oper_seg := copro.op and (zweipot[15] + zweipot[14] + zweipot[13] +
                            zweipot[12]);
  oper_off := copro.operand_Pointer;
  oper_point.ex := Ptr(oper_seg,oper_off);
  { --- Wer ist gerade Stacktop? --- }
  top := (copro.status_Word and topmask) div topdiv;
  { --- Einlesen der Marker aus Tag-Word --- }
  For i := 0 to 7 do
  begin
    marker[(8 + i - top) MOD 8] := (copro.tag_Word and (zweipot[i * 2] +
                                    zweipot[i * 2 + 1])) div zweipot[i * 2];
  end;

  { --- Welche Aktionen sollen ausgefuehrt werden? --- }
  opt_dump := (copro.status_Word and dump_on) <> 0;
  opt_exit := (copro.status_Word and Exit_on) <> 0;
  opt_ask  := (copro.status_Word and ask_on ) <> 0;
  opt_auto := (copro.status_Word and auto_on) <> 0;

  { === Aktionen ============================================ }
  if opt_dump then
    showcopro;
  if opt_exit then
  begin
    WriteLN;
    WriteLN('Exit Program due to Programmers request');
    HALT; { Bye, bye ... }
  end;
  if opt_dump and not (opt_ask) then
    choice;

  copro.control_Word := copro.control_Word or anyerrors;
  Asm
    frstor copro
    fclex
  end;
  { --- Befehl nochmals ausfuehren --- }
  if (occured and do_again) <> 0 then
    do_it_again;
  { --- Noch was? --- }
  if opt_auto then
    auto_corr;
  if opt_ask  then
    ask_correct;
  restore_masks;
end;

{ ------------- Ein- und Ausschalten ------------- }

Procedure handle_on;
begin
  Getintvec($75, normal.adr);
  Setintvec($75, @errorcon);
end;

Procedure handle_off;
begin
  Setintvec($75, normal.adr);
end;

begin
  handle_on;
  dump_on :=0;
  Exit_on :=0;
  ask_on  :=0;
  auto_on :=0;
  standard:=0;
  do_again:=invalid+zero_div+denormal;
  clear_copro;
end.






Unit dis387;

Interface

Function dis(opco : Word) : String;

Implementation

Function dis;
Var
  d, op : String;

  Procedure opcr(st : Word);
  Var
    t : String;
  begin
    str(st, t);
    op := ' st,st(' + t + ')';
  end;

  Procedure opc(st : Word);
  Var
    t : String;
  begin
    str(st, t);
    op := ' st(' + t + '),st';
  end;

  Procedure op1(st : Word);
  Var
    t : String;
  begin
    str(st, t);
    op := ' st(' + t + ')';
  end;

begin
  d  := '...';
  op := '';

  Case Hi(opco) OF
    $d8 :
      Case Lo(opco) div 16 OF
        $c :
          if opco MOD 16 >= 8 then
          begin
            d := 'fmul';
            opcr(opco MOD 16 - 8);
          end
          else
          begin
            d := 'fadd';
            opcr(opco MOD 16);
          end;

        $e :
          if opco MOD 16 >= 8 then
          begin
            d := 'fsubr';
            opcr(opco MOD 16 - 8);
          end
          else
          begin
            d := 'fsub';
            opcr(opco MOD 16);
          end;

        $f :
          if opco MOD 16 >= 8 then
          begin
            d := 'fdivr';
            opcr(opco MOD 16 - 8);
          end
          else
          begin
            d := 'fdiv';
            opcr(opco MOD 16);
          end;
      end;

   $d9 :
     Case Lo(opco) OF
       $d0 : d := 'fnop';
       $e0 : d := 'fchs';
       $e1 : d := 'fabs';
       $e4 : d := 'ftst';
       $e5 : d := 'fxam';
       $e8 : d := 'fld1';
       $e9 : d := 'fld2t';
       $ea : d := 'fld2e';
       $eb : d := 'fldpi';
       $ec : d := 'fldlg2';
       $ed : d := 'fldln2';
       $ee : d := 'fldz';
       $f0 : d := 'f2xm1';
       $f1 : d := 'fyl2x';
       $f2 : d := 'fptan';
       $f3 : d := 'fpatan';
       $f4 : d := 'fxtract';
       $f5 : d := 'fprem1';
       $f6 : d := 'fdecstp';
       $f7 : d := 'fincstp';
       $f8 : d := 'fprem';
       $f9 : d := 'fyl2xp1';
       $fa : d := 'fsqrt';
       $fb : d := 'fsincos';
       $fc : d := 'frndint';
       $fd : d := 'fscale';
       $fe : d := 'fsin';
       $ff : d := 'fcos';
     end;

   $db :
     Case Lo(opco) OF
       $e2 : d := 'fclex';
       $e3 : d := 'finit';
     end;
   $dc :
     Case Lo(opco) div 16 OF
       $c :
         if opco MOD 16 >= 8 then
         begin
           d := 'fmul';
           opc(opco MOD 16-8);
         end
         else
         begin
           d := 'fadd';
           opc(opco MOD 16);
         end;

       $e : if opco MOD 16 >= 8 then
         begin
           d := 'fsub';
           opc(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fsubr';
           opc(opco MOD 16);
         end;

       $f :
         if opco MOD 16 >= 8 then
         begin
           d := 'fdiv';
           opc(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fdivr';
           opc(opco MOD 16);
         end;
     end;

   $dd :
     Case Lo(opco) div 16 OF
       $c :
         begin
           d := 'ffree';
           op1(opco MOD 16);
         end;
       $d :
         if opco MOD 16 >= 8 then
         begin
           d := 'fstp';
           op1(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fst';
           op1(opco MOD 16);
         end;
       $e :
         if opco MOD 16 >= 8 then
         begin
           d := 'fucomp';
           op1(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fucom';
           op1(opco MOD 16);
         end;
     end;

   $de :
     Case Lo(opco) div 16 OF
       $c :
         if opco MOD 16 >= 8 then
         begin
           d := 'fmulp';
           opc(opco MOD 16 - 8);
         end
         else
         begin
           d := 'faddp';
           opc(opco MOD 16);
         end;

       $d : d := 'fcompp';

       $e :
         if opco MOD 16 >= 8 then
         begin
           d := 'fsubp';
           opc(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fsubrp';
           opc(opco MOD 16);
         end;

       $f :
         if opco MOD 16 >= 8 then
         begin
           d := 'fdivp';
           opc(opco MOD 16 - 8);
         end
         else
         begin
           d := 'fdivrp';
           opc(opco MOD 16);
         end;
     end;
   end;

   dis := d + op;
end;

begin
end.